home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / hash.scm < prev    next >
Text File  |  1999-04-19  |  4KB  |  154 lines
  1. ; "hash.scm", hashing functions for Scheme.
  2. ; Copyright (c) 1992, 1993, 1995 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define (hash:hash-char-ci char n)
  21.   (modulo (char->integer (char-downcase char)) n))
  22.  
  23. (define hash:hash-char hash:hash-char-ci)
  24.  
  25. (define (hash:hash-symbol sym n)
  26.   (hash:hash-string (symbol->string sym) n))
  27.  
  28. ;;; This can overflow on implemenatations where inexacts have a larger
  29. ;;; range than exact integers.
  30. (define hash:hash-number
  31.   (if (provided? 'inexact)
  32.       (lambda (num n)
  33.     (if (integer? num)
  34.         (modulo (if (exact? num) num (inexact->exact num)) n)
  35.         (hash:hash-string-ci
  36.          (number->string (if (exact? num) (exact->inexact num) num))
  37.          n)))
  38.       (lambda (num n)
  39.     (if (integer? num)
  40.         (modulo num n)
  41.         (hash:hash-string-ci (number->string num) n)))))
  42.  
  43. (define (hash:hash-string-ci str n)
  44.   (let ((len (string-length str)))
  45.     (if (> len 5)
  46.     (let loop ((h (modulo 264 n)) (i 5))
  47.       (if (positive? i)
  48.           (loop (modulo (+ (* h 256)
  49.                    (char->integer
  50.                 (char-downcase
  51.                  (string-ref str (modulo h len)))))
  52.                 n)
  53.             (- i 1))
  54.           h))
  55.     (let loop ((h 0) (i (- len 1)))
  56.       (if (>= i 0)
  57.           (loop (modulo (+ (* h 256)
  58.                    (char->integer
  59.                 (char-downcase (string-ref str i))))
  60.                 n)
  61.             (- i 1))
  62.           h)))))
  63.  
  64. (define hash:hash-string hash:hash-string-ci)
  65.  
  66. (define (hash:hash obj n)
  67.   (let hs ((d 10) (obj obj))
  68.     (cond
  69.      ((number? obj)      (hash:hash-number obj n))
  70.      ((char? obj)        (modulo (char->integer (char-downcase obj)) n))
  71.      ((symbol? obj)      (hash:hash-symbol obj n))
  72.      ((string? obj)      (hash:hash-string obj n))
  73.      ((vector? obj)
  74.       (let ((len (vector-length obj)))
  75.     (if (> len 5)
  76.         (let lp ((h 1) (i (quotient d 2)))
  77.           (if (positive? i)
  78.           (lp (modulo (+ (* h 256)
  79.                  (hs 2 (vector-ref obj (modulo h len))))
  80.                   n)
  81.               (- i 1))
  82.           h))
  83.         (let loop ((h (- n 1)) (i (- len 1)))
  84.           (if (>= i 0)
  85.           (loop (modulo (+ (* h 256) (hs (quotient d len)
  86.                          (vector-ref obj i)))
  87.                 n)
  88.             (- i 1))
  89.           h)))))
  90.      ((pair? obj)
  91.       (if (positive? d) (modulo (+ (hs (quotient d 2) (car obj))
  92.                    (hs (quotient d 2) (cdr obj)))
  93.                 n)
  94.       1))
  95.      (else
  96.       (modulo
  97.        (cond
  98.     ((null? obj)        256)
  99.     ((boolean? obj)     (if obj 257 258))
  100.     ((eof-object? obj)  259)
  101.     ((input-port? obj)  260)
  102.     ((output-port? obj) 261)
  103.     ((procedure? obj)   262)
  104.     ((and (provided? 'RECORD) (record? obj))
  105.      (let* ((rtd (record-type-descriptor obj))
  106.         (fns (record-type-field-names rtd))
  107.         (len (length fns)))
  108.        (if (> len 5)
  109.            (let lp ((h (modulo 266 n)) (i (quotient d 2)))
  110.          (if (positive? i)
  111.              (lp (modulo
  112.               (+ (* h 256)
  113.                  (hs 2 ((record-accessor
  114.                      rtd (list-ref fns (modulo h len)))
  115.                     obj)))
  116.               n)
  117.              (- i 1))
  118.              h))
  119.            (let loop ((h (- n 1)) (i (- len 1)))
  120.          (if (>= i 0)
  121.              (loop (modulo
  122.                 (+ (* h 256)
  123.                    (hs (quotient d len)
  124.                    ((record-accessor
  125.                      rtd (list-ref fns (modulo h len)))
  126.                     obj)))
  127.                 n)
  128.                (- i 1))
  129.              h)))))
  130.     (else               263))
  131.        n)))))
  132.  
  133. (define hash hash:hash)
  134. (define hashv hash:hash)
  135.  
  136. ;;; Object-hash is somewhat expensive on copying GC systems (like
  137. ;;; PC-Scheme and MITScheme).  We use it only on strings, pairs,
  138. ;;; vectors, and records.  This also allows us to use it for both
  139. ;;; hashq and hashv.
  140.  
  141. (if (provided? 'object-hash)
  142.     (set! hashv
  143.       (if (provided? 'record)
  144.           (lambda (obj k)
  145.         (if (or (string? obj) (pair? obj) (vector? obj) (record? obj))
  146.             (modulo (object-hash obj) k)
  147.             (hash:hash obj k)))
  148.           (lambda (obj k)
  149.         (if (or (string? obj) (pair? obj) (vector? obj))
  150.             (modulo (object-hash obj) k)
  151.             (hash:hash obj k))))))
  152.  
  153. (define hashq hashv)
  154.